{-# LANGUAGE ExistentialQuantification  #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  OchreLang.Compile
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
--
--
--------------------------------------------------------------------------------


module OchreLang.Compile
  ( 

    CompilerOpts(..)
  , compile
  , runCompile


  ) where

import OchreLang.Alpha
import OchreLang.Assoc
import OchreLang.Beta
import OchreLang.CheckInter
import OchreLang.CompilerMon
import OchreLang.ConstFold
import qualified OchreLang.CsoundSyntax         as Csound
import qualified OchreLang.CsoundTrans          as Csound
import OchreLang.ElimLet
import OchreLang.ElimTuple
import OchreLang.ExpandMain
import OchreLang.FlattenInheritance
import OchreLang.FlattenTraits
import OchreLang.InlineLetfun
import OchreLang.InlineSuper
import OchreLang.IntroInitDecls
import OchreLang.ModuleIO
import qualified OchreLang.OrchSpec             as OS
import qualified OchreLang.Syntax               as Inter
import qualified OchreLang.ToplevelTrans        as Top
import qualified OchreLang.TopSyntax            as Top
import OchreLang.Utils ( vspaced, passM, repeatM ) 


import Text.PrettyPrint.HughesPJ (render )      -- package: pretty

import Control.Applicative
import Control.Monad
import qualified Data.Map as Map
import System.Exit
import System.FilePath
import Prelude hiding ( log )



data CompilerOpts = CompilerOpts
    { opt_search_path           :: SearchPath
    , opt_builtins_loc          :: FilePath
    , opt_optimize_count        :: Int
    , opt_verbose               :: Bool
    , opt_ddump_flags           :: [DDumpOpt]
    , opt_output_file           :: FilePath
    }


compile :: CompilerOpts -> FilePath -> IO ()
compile = flip runCompile 


-- Potentially should support something like GHC\'s -ddump-pass

runCompile :: FilePath -> CompilerOpts -> IO ()
runCompile main_path (CompilerOpts { opt_search_path    = searches
                                   , opt_builtins_loc   = builtins_path
                                   , opt_optimize_count = pc
                                   , opt_verbose        = verbo
                                   , opt_ddump_flags    = dd_flags 
                                   , opt_output_file    = out1 }) = 
    do { (log,ans) <- runCompilerMonad config $ 
                        do { (builts,prgm) <- loadProgram builtins_path main_path
                           ; withBuiltins builts (compileProgram prgm)
                           }
       ; case ans of
           Left err -> putStrLn log >> exitWithErr err
           Right a -> putStrLn log >> writeFile outpath (render $ Csound.ppOrchestra a)
       }
  where
    config = makeConfig pc searches dd_flags verbo
    exitWithErr err = do { putStrLn err; exitWith $ ExitFailure (-1) }
    outpath = if null out1 then (replaceExtension main_path "orc") else out1


-- | Ideally this function should do each part of the compilation 
-- step-by-step and on the /most obvious/ objects. Then this 
-- would be the only function that we need to annotate with ddump- 
-- calls
-- 
compileProgram :: Top.Program -> Compiler Csound.Orchestra
compileProgram prgm@(Top.Program { Top.program_orch_spec = ospec }) =
    let instances  = OS.extractInstances ospec in
    do { ddumpParsed prgm
       ; traits         <- passM ddumpTraits            =<< allTraits prgm
       ; prgm_tflat     <- passM ddumpInlineTraits      =<< stepInlineTraits traits prgm
       ; prgm_iflat     <- passM ddumpFlatInheritance   =<< stepFlattenInheritance prgm_tflat
       ; instr_dict     <- passM ddumpInstrumentDict    =<< Top.transProgram prgm_iflat
       ; orch           <- passM ddumpInterInitialOrch  =<< stepGetOrchestra instances instr_dict
       ; let methods    = Inter.buildMethodDict instr_dict
       ; orch_no_lam    <- passM ddumpInlineLetfun      =<< stepInlineLetfun orch
       ; orch_no_super  <- passM ddumpInlineSuper       =<< stepInlineSuper methods orch_no_lam
       ; orch_exp_main  <- passM ddumpExpandMain        =<< stepExpandMain orch_no_super
       ; orch_no_tuple  <- passM ddumpElimTuple         =<< stepElimTuple  orch_exp_main
       ; orch_optimize  <- passM ddumpOptimizeInter     =<< stepOptimizeInter orch_no_tuple
       ; orch_full      <- passM ddumpIntroInitDecls    =<< stepIntroInitDecls orch_optimize
       ; Inter.foreachM_Instrument allBound orch_full
       ; orch_csound    <-                               stepTransToCsound orch_full
       ; return orch_csound
       }

    


stepInlineTraits :: TraitDefns -> Top.Program -> Compiler Top.Program
stepInlineTraits trait_dict = Top.mapM_Module (flattenTraits trait_dict)

stepFlattenInheritance :: Top.Program -> Compiler Top.Program
stepFlattenInheritance = Top.mapM_Module flattenInheritance

stepGetOrchestra :: [OS.InstrInstance] 
                 -> Inter.InstrumentDict 
                 -> Compiler Inter.Orchestra
stepGetOrchestra instances dict = case Inter.findOrchestra instances dict of
    Left err -> throwError "Compile.setGetOrchestra" err
    Right orch -> return orch
         

stepInlineLetfun :: Inter.Orchestra 
                 -> Compiler Inter.Orchestra
stepInlineLetfun = Inter.mapM_Instrument inlineLetfun


stepInlineSuper :: Inter.MethodDict 
                -> Inter.Orchestra 
                -> Compiler Inter.Orchestra
stepInlineSuper dict = Inter.mapM_Instrument (inlineSuper dict)

stepExpandMain :: Inter.Orchestra -> Compiler Inter.Orchestra
stepExpandMain = Inter.mapM_Instrument expandMain

stepElimTuple :: Inter.Orchestra -> Compiler Inter.Orchestra
stepElimTuple = Inter.mapM_Instrument elimTuple

stepOptimizeInter :: Inter.Orchestra -> Compiler Inter.Orchestra
stepOptimizeInter = Inter.mapM_Instrument optimizeInst


stepIntroInitDecls :: Inter.Orchestra -> Compiler Inter.Orchestra
stepIntroInitDecls = Inter.mapM_InstrumentSource introInitDecls

stepTransToCsound :: Inter.Orchestra -> Compiler Csound.Orchestra
stepTransToCsound = Csound.orchestra




-- | Finish with an alpha rename so we get variables starting 
-- from 1.
--
optimizeInst  :: Inter.Instrument -> Compiler Inter.Instrument
optimizeInst ins@(Inter.Instrument {Inter.instr_main = emain}) = 
    (\main1 -> ins {  Inter.instr_main = main1 }) <$> process emain
  where
    process = alphaExpr >=> (\a -> askPassCount >>= \i -> repeatM i optimizeSteps a) 
                        >=> alphaExpr



-- | In MinCaml the optimization steps are repeated as a round
-- of simplification may introduce further opportunities for
-- optimization.
--
optimizeSteps :: Inter.Expr -> Compiler Inter.Expr
optimizeSteps = elimLet <=< constFold <=< assoc <=< beta
   





----------------------------------------------------------------------------------
-- Debugging dump

ddumpParsed :: Top.Program -> Compiler ()
ddumpParsed prgm = queryDDumpOpt DDUMP_PARSED >>= \a -> 
    when a $ ddump "Parsed" (Top.ppProgram prgm)


ddumpTraits :: TraitDefns -> Compiler ()
ddumpTraits defs = queryDDumpOpt DDUMP_TRAITS >>= \a ->
    when a $ ddump "Traits" (vspaced $ map pp $ Map.toList defs)
  where
    pp (name,def) = Top.ppTrait $ Top.Trait name def

ddumpInlineTraits :: Top.Program -> Compiler ()
ddumpInlineTraits prgm = queryDDumpOpt DDUMP_INLINE_TRAITS >>= \a ->
    when a $ ddump "Inlined Traits" (Top.ppProgram prgm)

ddumpFlatInheritance :: Top.Program -> Compiler ()
ddumpFlatInheritance prgm = queryDDumpOpt DDUMP_FLAT_INH >>= \a ->
    when a $ ddump "Inlined Inheritance" (Top.ppProgram prgm)

ddumpInstrumentDict :: Inter.InstrumentDict -> Compiler ()
ddumpInstrumentDict dict = queryDDumpOpt DDUMP_INSTR_DICT >>= \a ->
    when a $ ddump "Insts translated to Inter form" 
                   (vspaced $ map Inter.ppInstrument $ Map.elems dict)

ddumpInterInitialOrch :: Inter.Orchestra -> Compiler ()
ddumpInterInitialOrch orch = queryDDumpOpt DDUMP_INTER_ORC1 >>= \a ->
    when a $ ddump "Initial Orchestra in Inter form" 
                   (Inter.ppOrchestra orch)

ddumpInlineLetfun :: Inter.Orchestra -> Compiler ()
ddumpInlineLetfun orch = queryDDumpOpt DDUMP_INLINE_LETFUN >>= \a ->
    when a $ ddump "Inlined Letfuns"  (Inter.ppOrchestra orch)

ddumpInlineSuper :: Inter.Orchestra -> Compiler ()
ddumpInlineSuper orch = queryDDumpOpt DDUMP_INLINE_SUPER >>= \a ->
    when a $ ddump "Inlined Super"  (Inter.ppOrchestra orch)

ddumpExpandMain :: Inter.Orchestra -> Compiler ()
ddumpExpandMain orch = queryDDumpOpt DDUMP_EXPAND_MAIN >>= \a ->
    when a $ ddump "Expand Main"  (Inter.ppOrchestra orch)

ddumpElimTuple :: Inter.Orchestra -> Compiler ()
ddumpElimTuple orch = queryDDumpOpt DDUMP_ELIM_TUPLE >>= \a ->
    when a $ ddump "Eliminate Tuples"  (Inter.ppOrchestra orch)

ddumpOptimizeInter :: Inter.Orchestra -> Compiler ()
ddumpOptimizeInter orch = queryDDumpOpt DDUMP_OPTIMIZE_INTER >>= \a ->
    when a $ ddump "Optimize"  (Inter.ppOrchestra orch)

ddumpIntroInitDecls :: Inter.Orchestra -> Compiler ()
ddumpIntroInitDecls orch = queryDDumpOpt DDUMP_INTRO_INITS >>= \a ->
    when a $ ddump "Introduce Inits"  (Inter.ppOrchestra orch)
